home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 3 / Cream of the Crop 3.iso / comm / 0141ter2.zip / 0141TER2._XE / PASCAL.EXE / MAKEBBS.PAS < prev    next >
Pascal/Delphi Source File  |  1993-11-28  |  6KB  |  233 lines
  1. {$M 16384,100000,100000}
  2. Program FilesBBSmaker;
  3.  
  4. { This utility will search all the filelists specified in MAKEBBS.CFG    }
  5. { for decriptions and create a FILES.BBS, usefull if you have a large    }
  6. { download directory and you don't know the descriptions for the files   }
  7. { Then this program will do all the work for you. 1993 by Bo Bendtsen    }
  8. { Totally freeware, make any modifications you like, just remember to    }
  9. { give some thanx or credits to me.                                      }
  10.  
  11. Uses Crt,Dos;
  12.  
  13. Const
  14.   MaxFiles = 4000;
  15.  
  16. Type
  17.   BufType = Array[1..32768] of Char;
  18.  
  19. Var
  20.   List,I,Out : Text;
  21.   Buf        : ^BufType;                      { For reading textfiles faster }
  22.   CfgBuf     : Array[1..1024] of Char;
  23.   OutBuf     : Array[1..1024] of Char;
  24.   Info       : SearchRec;
  25.   Name       : Array[1..MaxFiles] of String[12];    { filenames in directory }
  26.   L,X,Y,left : Word;
  27.   Stop       : Boolean;
  28.   C          : Longint;
  29.   S,UPS      : String;
  30.   StartPos,p : Byte;
  31.   DescPos    : Byte;
  32.   ReadNext   : Boolean;
  33.  
  34. Function GrabWord(S: String; B: Byte) : String;
  35. Var st,e:Byte;
  36.     return : String[80];
  37. Begin
  38.   Return:='';
  39.   st:=1;e:=1;
  40.   While B>0 Do
  41.   Begin
  42.     While (S[st]=' ') or (S[st]=#9) Do Inc(st);  { #9 er TAB }
  43.     e:=st;
  44.     While (S[e]<>' ') And (e<=Length(s)) Do Inc(e);
  45.     Return:=Copy(S,st,e-st);
  46.     st:=e;
  47.     Dec(B);
  48.   End;
  49.   GrabWord:=Return;
  50. End;
  51.  
  52. Function StrToInt(S: String) : LongInt;
  53. Var
  54.   Kode : Integer;
  55.   i    : LongInt;
  56.   b    : Byte;
  57. Begin
  58.   b:=Length(s);
  59.   While b>0 Do
  60.   Begin
  61.     If s[b] in [#0..#255]-['0'..'9'] Then Delete(s,b,1);
  62.     Dec(b);
  63.   End;
  64.   If Length(S) = 0 Then StrToInt := 0 Else Begin
  65.     Val(S,i,Kode);
  66.     If Kode = 0 Then StrToInt := i Else StrToInt := 0;
  67.   End;
  68. End;
  69.  
  70. Function StUpcase(s:string):string;
  71. Var i :byte;
  72. Begin
  73.   for i := 1 to Length(s) do s[i] := UpCase(s[i]);
  74.   StUpcase:=s;
  75. End;
  76.  
  77. Function BlankAfter(S : String; Len : Byte): String;
  78. var
  79.   o : string;
  80.   SLen : Byte absolute S;
  81. Begin
  82.   If Length(S) >= Len then BlankAfter := S
  83.   Else begin
  84.     o[0] := Chr(Len);
  85.     Move(S[1], o[1], SLen);
  86.     if SLen < 255 then FillChar(o[Succ(SLen)], Len-SLen, ' ');
  87.     BlankAfter := o;
  88.   End;
  89. End;
  90.  
  91. Procedure LookForMore;  { Look for extra descriptions on following lines }
  92. Begin
  93.   s:=' ';
  94.   While (s<>'') And (s[1]=' ') And Not Eof(I) Do
  95.   Begin
  96.     ReadLn(I,S);
  97.     If (s<>'') And (s[1]=' ') Then WriteLn(Out,s);
  98.   End;
  99.   ReadNext:=False;
  100. End;
  101.  
  102. Begin
  103.   TextAttr:=7; ClrScr; TextAttr:=16*7;
  104.   WriteLn('╒═════════════════════════════════════════════════════════════════════════════╕');
  105.   WriteLn('│     Filelist description searcher 1.20, made by Bo Bendtsen +45-42643827    │');
  106.   WriteLn('╘═════════════════════════════════════════════════════════════════════════════╛'#10);
  107.   TextAttr:=7;
  108.  
  109.   If paramcount=0 Then
  110.   Begin
  111.     WriteLn('This program will read all files specified in a directory and search the');
  112.     WriteLn('for descriptions in the filelists specified in MAKEBBS.CFG');
  113.     WriteLn(#10'Syntax: MAKEBBS path+wildcard');
  114.     WriteLn(   '        MAKEBBS C:\TERMINAT\DOWNLOAD\*.*');
  115.     WriteLn(   '        MAKEBBS C:\TERMINAT\DOWNLOAD\*.GIF');
  116.     Halt;
  117.   End;
  118.  
  119.   Assign(List,Copy(ParamStr(0),1,Length(ParamStr(0))-3)+'CFG');
  120.   SetTextBuf(I,CfgBuf);
  121.   {$I-} Reset(List); {$I+}
  122.   If IOResult<>0 Then
  123.   Begin
  124.     WriteLn('Unable to open config file');
  125.     Halt;
  126.   End;
  127.  
  128.   L:=0; Fillchar(Name,sizeof(name),0);
  129.   WriteLn('Reading files '+Paramstr(1));
  130.   FindFirst(Paramstr(1),Archive,Info);
  131.   While (DosError=0) And (L<MaxFiles) Do
  132.   Begin
  133.     If l mod 25=0 Then Write(#13,l);
  134.     Inc(L);
  135.     Name[L]:=Info.Name;
  136.     If Pos('.',Name[L])=0 Then Name[L]:=Name[L]+'.';
  137.     FindNext(Info);
  138.   End;
  139.   Left:=L;
  140.  
  141.   If L=0 Then
  142.   Begin
  143.     WriteLn('No files to find');
  144.     Halt;
  145.   End;
  146.  
  147.   Assign(Out,'FILES.BBS');
  148.   SetTextBuf(I,OutBuf);
  149.   {$I-} Append(Out); {$I+}
  150.   If IOResult<>0 Then
  151.   Begin
  152.     {$I-} Rewrite(Out); {$I+}
  153.     If IOResult<>0 Then
  154.     Begin
  155.       WriteLn('Unable to write to FILES.BBS');
  156.       Halt;
  157.     End;
  158.     WriteLn(#13#10'Creating FILES.BBS');
  159.   End
  160.   Else WriteLn(#13#10'Appending to FILES.BBS');
  161.  
  162.   New(Buf);
  163.   While Not Eof(List) And Not Keypressed Do
  164.   Begin
  165.     ReadLn(List,S);
  166.     ReadNext:=True;
  167.     If (S<>'') And Not (S[1] in [';','%']) Then
  168.     Begin
  169.       WriteLn(GrabWord(s,1));
  170.       StartPos:=StrToInt(GrabWord(s,2)); If StartPos=0 Then StartPos:=1;
  171.       DescPos:=StrToInt(GrabWord(s,3));  If DescPos=0 Then DescPos:=1;
  172.       Assign(I,GrabWord(s,1));
  173.       SetTextBuf(I,Buf^);
  174.       {$I-} Reset(I); {$I+}
  175.       If IOResult<>0 Then WriteLn('Unable to open input file')
  176.       Else Begin
  177.         WriteLn(Out);
  178.         WriteLn(Out,' - MakeBBS : '+GrabWord(s,1));
  179.         WriteLn(Out);
  180.  
  181.         Stop:=False; C:=0;
  182.         While Not Eof(I) And Not Stop And (Left>0) Do
  183.         Begin
  184.           Inc(C);
  185.           If C Mod 100=0 Then
  186.           Begin
  187.             Stop:=KeyPressed;
  188.             Write(#13,'Lines: ',C,', missing ',Left,'      ');
  189.           End;
  190.           If ReadNext Then ReadLn(I,S);
  191.           ReadNext:=True;
  192.           If S<>'' Then
  193.           Begin
  194.             UPS:=StUpcase(S);
  195.             For x:=1 To L Do
  196.             Begin
  197.               If Pos(Name[x],UPS)=StartPos Then
  198.               Begin
  199.                 Dec(Left);
  200.                 WriteLn(Out,BlankAfter(Name[x],13)+Copy(S,DescPos,255));
  201.                 Name[x]:='';
  202.                 LookForMore;
  203.               End
  204.               Else Begin
  205.                 p:=Pos('.',Name[x]);
  206.                 If Pos(Copy(Name[x],1,p),UPS)=StartPos Then
  207.                 Begin
  208.                   Dec(Left);
  209.                   If Name[x][Length(Name[x])]='.' Then Name[x][0]:=Chr(Ord(Name[x][0])-1);
  210.                   WriteLn(Out,BlankAfter(Name[x],13)+Copy(S,DescPos,255));
  211.                   Name[x]:='';
  212.                   LookForMore;
  213.                 End
  214.               End;
  215.             End;
  216.           End;
  217.         End;
  218.  
  219.         Write(#13,'Lines: ',C,', missing ',Left,'      ');
  220.         WriteLn(#13#10'Lines processed: ',C);
  221.  
  222.         Close(I);
  223.       End;
  224.     End;
  225.   End;
  226.   Dispose(Buf);
  227.   If KeyPressed Then WriteLn(#13#10#10'Keyboard abort');
  228.  
  229.   Close(List);
  230.   Close(Out);
  231. End.
  232.  
  233.